home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DBASE_UT / TPDB335 / TPDBSCRN.PAS < prev    next >
Pascal/Delphi Source File  |  1993-11-26  |  4KB  |  176 lines
  1. unit TPDBScrn;
  2.  
  3.                            (***********************************)
  4.                            (*               TPDB              *)
  5.                            (***********************************)
  6.                            (*         Object -Oriented        *)
  7.                            (*    Borland/Turbo Pascal Units   *)
  8.                            (*    for Accessing dBASE III      *)
  9.                            (*             files.              *)
  10.                            (*      Copyright 1988 - 1993      *)
  11.                            (*          Brian Corll            *)
  12.                            (*       All Rights Reserved       *)
  13.                            (***********************************)
  14.                            (*            FREEWARE             *)
  15.                            (***********************************)
  16.                            (*     dBASE is a registered       *)
  17.                            (* trademark of Borland Int. Inc.  *)
  18.                            (*   Version 3.35  November, 1993  *)
  19.                            (***********************************)
  20.                            (*   Portions Copyright 1984,1991  *)
  21.                            (*    Borland International Corp.  *)
  22.                            (***********************************)
  23. {$L Flash}
  24. {$L Attr}
  25.  
  26. interface
  27. Uses Crt;
  28.  
  29. const
  30. {Color constants - defined to take advantage of Turbo Pascal's
  31.  constant folding capabilities.  See documentation.}
  32.  
  33.  
  34.     Black = $00;
  35.     DarkGray = $08;
  36.     Blue = $01;
  37.     LightBlue = $09;
  38.     Green = $02;
  39.     LightGreen = $0A;
  40.     Cyan = $03;
  41.     LighBCyan = $0B;
  42.     Red = $04;
  43.     LightRed = $0C;
  44.     Magenta = $05;
  45.     LightMagenta = $0D;
  46.     Brown = $06;
  47.     Yellow = $0E;
  48.     LightGray = $07;
  49.     White = $0F;
  50.     Blink = $80;
  51.  
  52.     BlackBG = $00;
  53.     BlueBG = $10;
  54.     GreenBG = $20;
  55.     CyanBG = $30;
  56.     RedBG = $40;
  57.     MagentaBG = $50;
  58.     BrownBG = $60;
  59.     LightGrayBG = $70;
  60.  
  61. type
  62.     ScreenType = array [0..3999] of byte;
  63.     ScrPtr = ^ScreenType;
  64.     DisplayType = (Monochrome, CGA, EGA, MCGA, VGA);
  65.  
  66. var
  67.     VideoBase: word;
  68.     VideoWait: boolean;
  69.  
  70.  
  71.  
  72. function SaveScreen: ScrPtr;
  73.  
  74. procedure RestoreScreen(var SavedScreen: ScrPtr);
  75.  
  76. procedure Flash(Row, Col, Attr: byte; Str: string);
  77.  
  78. procedure CursorOn;
  79.  
  80. procedure CursorOff;
  81.  
  82. procedure BlockCursor;
  83.  
  84. procedure ChAttr(Number: word; Row, Col, Attr: word);
  85.  
  86. procedure ChAllAttr(Row, Col, Rows, Cols, Attr: word);
  87.  
  88. procedure FlashC(Row, Attr: byte; Str: string);
  89.  
  90.  
  91. implementation
  92.  
  93. var
  94.     Screen: ScreenType absolute SegB800;
  95.     MonoScreen: ScreenType absolute SegB000;
  96.     Mono: boolean;
  97.  
  98. {$F+}
  99.  
  100. procedure Flash(Row, Col, Attr: byte; Str: string);
  101. external;
  102.  
  103. function CurrVidDisplay: DisplayType;
  104. external;
  105.  
  106. function CurrentVideoMode: byte;
  107. external;
  108.  
  109. procedure CursorOn;
  110. external;
  111.  
  112. procedure CursorOff;
  113. external;
  114.  
  115. procedure BlockCursor;
  116. external;
  117.  
  118. procedure ChAttr(Number: word; Row, Col, Attr: word);
  119. external;
  120.  
  121.  
  122.  
  123. {$F-}
  124.  
  125. procedure ChAllAttr(Row, Col, Rows, Cols, Attr: word);
  126.  
  127. var
  128.     TRow: byte;
  129.  
  130. begin
  131.     for TRow := Row to Rows do
  132.         ChAttr(Cols, TRow, Col, Attr);
  133. end;
  134.  
  135. procedure FlashC(Row, Attr: byte; Str: string);
  136.  
  137. begin
  138.     Flash(Row, 40 - Length(Str) div 2, Attr, Str);
  139. end;
  140.  
  141.  
  142. function SaveScreen: ScrPtr;
  143.  
  144. var
  145.     TempPtr: ScrPtr;
  146.  
  147. begin
  148.     New(TempPtr);
  149.     if Mono then
  150.         Move(MonoScreen, TempPtr^, 4000)
  151.     else
  152.         Move(Screen, TempPtr^, 4000);
  153.     SaveScreen := TempPtr;
  154. end;
  155.  
  156. procedure RestoreScreen(var SavedScreen: ScrPtr);
  157.  
  158. begin
  159.     if Mono then
  160.         Move(SavedScreen^, MonoScreen, 4000)
  161.     else
  162.         Move(SavedScreen^, Screen, 4000);
  163. end;
  164.  
  165.  
  166. begin
  167.     if CurrentVideoMode = 7 then begin
  168.         VideoBase := SegB000;
  169.         Mono := True;
  170.     end else begin
  171.         VideoBase := SegB800;
  172.         Mono := False;
  173.     end;
  174.     VideoWait := (CurrVidDisplay = CGA);
  175. end.
  176.